(require easy
         xhtml
         cj-sxml-serializer
         alist)

;; Well...
(defmacro (where expr bindings)
  `(let ,bindings ,expr))


;; Example data structure: --------------------------------------------

(defparameter current-db #f)
(def (xcurrent-db) (or (current-db) (error "not in a transaction")))

(defclass (ref [keyword? table-key] [natural? id]))

(def (ref-of [keyword? table-key])
     (lambda (v)
       (and (ref? v)
            (eq? (ref.table-key v) table-key))))

(def (resolve [ref? ref])
     (.resolve (xcurrent-db) ref))

(def (resolving access-ref)
     (lambda (s)
       (.resolve (xcurrent-db) (access-ref s))))

(defclass (shoppinglist-entry [natural? count]
                              [(ref-of product:) *product])
  (defmethod product (resolving .*product))

  (defmethod (cost s)
    (* count (.price (.product s))))

  (defmethod (html s)
    (HTML (tr (td count)
              (let (p (.product s))
                (list (td (.name p))
                      (td (.price p))
                      (td (.cost s))))))))


(defclass (db-object [natural? id])

  (defclass (person name surname address)

    (defmethod (html s)
      (HTML (div class: "person"
                 (b name " " surname) (br)
                 ,address))))

  (defclass (product [string? name]
                     [real? price]))

  (defclass (shoppinglist [(list-of shoppinglist-entry?) entries])
  
    (defmethod (html s)
      (HTML (div class: "shoppinglist"
                 (p "Shopping cart")
                 (table (thead (th "Count")
                               (th "Product name")
                               (th "Price")
                               (th "Cost"))
                        (.map entries .html)
                        (tr (td colspan: 3
                                align: "right"
                                (b "Total:"))
                            (td (=> entries (.map .cost) .sum))))))))

  (defclass (order [(ref-of person:) *person]
                   [(ref-of shoppinglist:) *shoppinglist])
    (defmethod person (resolving .*person))
    (defmethod shoppinglist (resolving .*shoppinglist))))


(modimport/prefix
 db-objects: (<alist> natural? db-object.id =))

(defclass (db [(list-of person?) persons]
              [(list-of product?) products]
              [(list-of shoppinglist?) shoppinglists]
              [(list-of order?) orders])

  (defmethod (resolve s [ref? ref])
    (where
     (xcase (.table-key ref)
            ((person:) (c .persons))
            ((product:) (c .products))
            ((shoppinglist:) (c .shoppinglists))
            ((order:) (c .orders)))
     (c (lambda (accessor)
          (db-objects:ref (accessor s) (.id ref))))))

  (defmethod (transaction s thunk)
    (parameterize ((current-db s))
                  (thunk))))

(defmacro (transaction db . body)
  `(.transaction ,db
                 (lambda () ,@body)))


;; Example data: --------------------------------------------

(def example-db
     (db (list (person 1 "Chris" "J" "Svizzera")
               (person 2 "Someone" "Else" "Anywhere"))
         (list (product 2 "Tooth brush" 1.23)
               (product 3 "Ginger beer" 3.40)
               (product 5 "Ginger bread" 2))
         (list (shoppinglist 1
                             (list))
               (shoppinglist 2
                             (list (shoppinglist-entry 10 (ref product: 3))
                                   (shoppinglist-entry 2 (ref product: 5)))))
         (list (order 1 (ref person: 2) (ref shoppinglist: 1))
               (order 2 (ref person: 1) (ref shoppinglist: 2)))))


(TEST
 > (.resolve example-db (ref person: 1))
 [(person) 1 "Chris" "J" "Svizzera"]
 > (%try (resolve (ref order: 2)))
 (exception text: "not in a transaction\n")
 > (transaction example-db (resolve (ref order: 2)))
 [(order) 2 [(ref) person: 1] [(ref) shoppinglist: 2]])


;; Page generation: --------------------------------------------

(def (superduper-page pagename body)
     (HTML (html
            (head
             (title pagename " - super duper html example")
             (style "
.person {
    background-color: lightblue;
}
.shoppinglist {
    background-color: aliceblue;
}
.shoppinglist table, th, td {
    border: 1px solid black;
}
"))
            (body
             (h1 pagename)
             ;; .. add navigation here...
             ,body))))

(def (superduper-shoppingcart-page order)
     (superduper-page "shopping cart"
                      (HTML
                       (p "For:")
                       (.html (.person order))
                       (.html (.shoppinglist order)))))


(TEST
 > (transaction example-db
                (=> (resolve (ref order: 2))
                    superduper-shoppingcart-page))
 (html (head (title "shopping cart" " - super duper html example")
             (style "\n.person {\n    background-color: lightblue;\n}\n.shoppinglist {\n    background-color: aliceblue;\n}\n.shoppinglist table, th, td {\n    border: 1px solid black;\n}\n"))
       (body (h1 "shopping cart")
             (##begin (p "For:")
                      (div (@ (class "person"))
                           (b "Chris" " " "J")
                           (br)
                           "Svizzera")
                      (div (@ (class "shoppinglist"))
                           (p "Shopping cart")
                           (table (thead (th "Count")
                                         (th "Product name")
                                         (th "Price")
                                         (th "Cost"))
                                  ((tr (td 10)
                                       ((td "Ginger beer") (td 3.4) (td 34.)))
                                   (tr (td 2)
                                       ((td "Ginger bread") (td 2) (td 4))))
                                  (tr (td (@ (align "right") (colspan 3))
                                          (b "Total:"))
                                      (td 38.))))))))

(def (t)
     (transaction example-db
                  (=> (resolve (ref order: 2))
                      superduper-shoppingcart-page
                      (sxml>>xhtml-file "htmlexample.xhtml"))))

;; run on file load:
(t)

